home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / defsys 5.0 / defpackage.l next >
Encoding:
Text File  |  1992-09-02  |  3.3 KB  |  93 lines  |  [TEXT/CCL2]
  1. ; -*- mode:     CL -*- ----------------------------------------------------- ;
  2. ; File:         defpackage.l
  3. ; Description:  CL defpackage
  4. ; Author:       Joachim H. Laubsch
  5. ; Created:      20-Sep-91
  6. ; Modified:     Tue Aug 11 12:04:31 1992 (Joachim H. Laubsch)
  7. ; Language:     CL
  8. ; Package:      USER
  9. ; RCS $Header: $
  10. ;
  11. ;;; *************************************************************************
  12. ;;; Copyright (c) 1989, Hewlett-Packard Company
  13. ;;; All rights reserved.
  14. ;;;
  15. ;;; Use and copying of this software and preparation of derivative works
  16. ;;; based upon this software are permitted.  Any distribution of this
  17. ;;; software or derivative works must comply with all applicable United
  18. ;;; States export control laws.
  19. ;;; 
  20. ;;; This software is made available AS IS, and Hewlett-Packard Company
  21. ;;; makes no warranty about the software, its performance or its conformity
  22. ;;; to any specification.
  23. ;;; 
  24. ;;; Suggestions, comments and requests for improvements are welcome
  25. ;;; and should be mailed to laubsch@hplabs.com.
  26. ;;; *************************************************************************
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28. ; Revisions:
  29. ; RCS $Log: $
  30. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31. ;; still incomplete!!
  32.  
  33. (in-package "USER")
  34. (provide "defpackage")
  35.  
  36. (defmacro defpackage (name &rest keylist &aux result)
  37.   `(let ((package 
  38.       (or (find-package ',name)
  39.           (make-package
  40.            ',name
  41.            ,@(let ((nn (assoc :nicknames keylist)))
  42.            (when nn
  43.              `(:nicknames ',(cdr (the cons nn)))))))))
  44.     ,@(dolist (pair (sort keylist
  45.               #'(lambda (x y)
  46.                   (member y (member x '(:shadow :shadowing-import-from
  47.                             :use :import-from
  48.                             :intern :export))))
  49.               :key #'car) (nreverse result))
  50.     (let* ((key (car pair))
  51.            (value (let ((v (cdr pair)))
  52.             (if (every #'(lambda (e)
  53.                        (or (symbolp e) (stringp e)))
  54.                    v)
  55.                 v
  56.               (error
  57.                "Key ~S should be followed by (unquoted) symbols or strings, not: ~% ~S"
  58.                key v))))
  59.            (cmd (case key
  60.               (:export `(dolist (x ',value)
  61.                  (export (intern (string x) package)
  62.                   package)))
  63.               (:unexport `(dolist (x ',value)
  64.                    (unexport (intern (string x) package)
  65.                     package)))
  66.               (:import-from
  67.                `(let ((p (find-package ,(car value))))
  68.              (import (mapcar #'(lambda (s)
  69.                          (or (intern (string s) p)
  70.                          (error "~S not found in ~S" s p)))
  71.                   ',(cdr value))
  72.               package)))
  73.               (:shadowing-import-from
  74.                `(let ((P ',(car value)))
  75.              (dolist (S ',(cdr value))
  76.                (let ((A (find-symbol (string S) (find-package P))))
  77.                  (if A
  78.                  (shadowing-import A package)
  79.                    (error "Defining ~A. Trying to do :SHADOWING-IMPORT-FROM ~S ~A, but ~A is not in package ~S" package P S S P))))))
  80.               (if `(shadowing-import  package))
  81.               (:shadow           `(shadow ',value package))
  82.               (:use              `(use-package ',value package))
  83.               (:unuse            `(unuse-package ',value package))
  84.               (:nicknames)
  85.               (T (error "Wrong key in defpackage: ~S" key)))))
  86.       (when cmd (push cmd result))))
  87.     package))
  88.  
  89.  
  90. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  91. ;;                             End of defpackage.l
  92. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  93.